perm filename MKWED[2,BGB] blob
sn#033836 filedate 1973-04-09 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00029 PAGES
RECORD PAGE DESCRIPTION
00001 00001
00005 00002 TITLE MKWED
00008 00003 SUBR(NEXRAD)OV,IV-------------------------------------------------
00010 00004 SUBR(TRYEASY)ARCO,ARCI-------------------------------------------
00012 00005 ARC OUTER IS "HIGHER".
00014 00006 SUBR(DISTANCE)V1,V2-----------------------------------------------
00015 00007 SUBR(TRYHARD)V0,V1-------------------------------------------------
00017 00008 COMPUTE LOCUS OF FOOT OF PERPENDICULAR DROPPED FROM V0.
00019 00009 SUBR(MKWED1)IMAGE-------------------------------------------------
00021 00010 SUBR(MKWED2)IMAGE-------------------------------------------------
00024 00011 SUBR(KL2SID)IMAGE-------------------------------------------------
00025 00012 TITLE WINGS - THE WINGED EDGE SUBROUTINES - JULY 1972.
00027 00013 FACE, EDGE & VERTEX MAKE PRIMITIVES.
00029 00014 SUBR(KLF)FNEW-----------------------------------------------------
00031 00015 SUBR(WING)E1,E2---------------------------------------------------
00033 00016 LINKED(Q1,Q2) - DETERMINE WHETHER TWO FEV ENTITIES ARE LINKED.
00036 00017 SUBR(ERIGHT)------------------------------------------------------
00038 00018 E←ECW(FROM-X,ABOUT-Y) - EDGE CLOCKWISE FROM X ABOUT Y.
00040 00019 SUBR(OTHER)-------------------------------------------------------
00042 00020 V ← VCW(E,F).
00045 00021 TITLE EULER - EULER SURFACE PRIMITIVES - JULY 1972 - BGB.
00047 00022 SUBR(MKEV)F,V-----------------------------------------------------
00049 00023 SUBR(MKFE)V1,F,V2-------------------------------------------------
00052 00024 CDR V2'S TAIL REPLACING +F'S WITH FNEW.
00054 00025 VNEW ← ESPLIT(E) "M" COMMAND.
00056 00026 SUBR(KLFE)ENEW----------------------------------------------------
00058 00027 SUBR(KLEV)VNEW----------------------------------------------------
00061 00028 SUBR(KLVE)ENEW----------------------------------------------------
00064 00029 SUBR(GLUEVV)F1,V1,F2,V2--------------------------------------------
00066 ENDMK
⊗;
TITLE MKWED
EXTERN SQRT,FLGKRK
SUBR(BUNDLE)LEVEL-------------------------------------------------
BEGIN BUNDLE; BGB - 28 DECEMBER 1972.
;MAKE ARC RADIAL POINTERS FROM THIS LEVEL TO BELOW.
;A SINGLE VIC RADIAL INDICATES PARALLEL COINCIDANT VIC.
;AN ARC INDICATES A SET OF NEARLY COLINEAR VIC.
SKIPN FLGKRK↔POP1J
LAC 1,ARG1 ;LEVEL
SON 1,1 ;POLYGON.
DAC 1,PG0 ;FIRST POLYGON.
;POLYGON PROCESSING LOOP.
L1: DAC 1,IPG↔EXO 0,1↔JUMPE L3
ARC 2,1↔DAC 2,ARCI↔ARC 2,2↔DAC 2,IV0↔DAC 2,IV1
JUMPE 2,[FATAL(BUNDLE)]
EXO 1,1↔ ARC 2,1↔DAC 2,ARCO↔ARC 2,2↔DAC 2,OV0↔DAC 2,OV1
JUMPE 2,[FATAL(BUNDLE)]
;VIC PROCCESSING LOOP.
L2: CALL(NEXRAD,OV1,IV1)↔GO L3↔DAC FLAG ;LAST TIME FLAG.
DAC 2,OV1↔DAC 3,IV1
DAC 4,ARCO
DAC 5,ARCI
TEST 4,ARCBIT↔GO[FATAL({ARCO AIN'T ARC})]
TEST 5,ARCBIT↔GO[FATAL({ARCI AIN'T ARC})]
CALL(TRYEASY,ARCO,ARCI)
SKIPN FLAG↔GO L2
;ADVANCE TO NEXT POLYGON OF THIS LEVEL.
L3: LAC 1,IPG↔CCW 1,1
CAME 1,PG0↔GO L1
POP1J↔LIT
DECLARE{IV1,OV1,FLAG,IPG,PG,PG0,ARCO,ARCI}
BEND;1/5/73-------------------------------------------------------
DECLARE{IV0,OV0}
BRAD1: 3.0
BRAD2: 1.8
SUBR(NEXRAD)OV,IV-------------------------------------------------
BEGIN NEXRAD; BGB - 28 DECEMBER 1972.
;GET NEXT NEW VERTEX WITH A RADIAL POINTER.
ACCUMULATORS{OV,IV,ARCO,ARCI,PG,R,S}
;RETURN VALUES PER ACCUMULATORS:
; AC-2 OV OUTER VERTEX.
; AC-3 IV INNER VERTEX.
; AC-4 ARCO ARC OUTER.
; AC-5 ARCI ARC INNER.
SETZ
LAC OV,ARG2
LAC IV,ARG1
PGON PG,IV
L0: SKIPE↔POP2J↔SETZ R,
;ADVANCE IV CCW UNTIL EXO RADIAL.
L1: EXO R,IV↔JUMPN R,L2
CCW IV,IV↔CAME IV,IV0↔GO L1
;ADVANCE OV CCW UNTIL ENDO RADIAL.
L2: ENDO S,OV↔JUMPN S,[
PGON 1,S↔CAME S,PG↔GO .+1
LAC IV,S↔SETZ R,↔GO L4]
CAMN OV,R↔GO L4
CCW OV,OV↔CAME OV,OV0↔GO L2↔POP2J
;BACKUP OV & IV CW TO A VERTEX WITH AN ARC.
L4: LAC 1,OV↔ARC ARCO,1↔JUMPN ARCO,.+3↔CW 1,1↔GO .-3
LAC 1,IV↔ARC ARCI,1↔JUMPN ARCI,.+3↔CW 1,1↔GO .-3
;ADVANCE ONE OR THE OTHER VIC POINTER FOR NEXT TIME.
L3: SKIPE R
GO[CCW IV,IV↔CAMN IV,IV0↔SETO↔GO .+4]
CCW OV,OV↔CAMN OV,OV0↔SETO
;IF ARCS ALREADY CONNECTED THEN PRESS ONWARD.
ENDO 1,ARCO↔CAMN 1,ARCI↔GO L0
EXO 1,ARCI↔CAMN 1,ARCO↔GO L0
AOS(P)↔POP2J↔LIT↔VAR
BEND;1/6/73-------------------------------------------------------
SUBR(TRYEASY)ARCO,ARCI-------------------------------------------
BEGIN TRYEASY;TEST FOR EASY CASES AND CALL TRYHARD FOR HARD CASES.
;BGB - 28 DEC 1972 - ARC ARGUMENTS ALLEGED COINCIDENT & PARALLEL.
ACCUMULATORS{ARCO,ARCI,ARCO2,ARCI2,R,C}
;"UPPER" VERTICES OF THE PARALLELS.
SETZM FLAG#
LAC ARCO,ARG2
LAC ARCI,ARG1
;TEST FOR EASY CASE.
CALL(DISTANCE,ARCO,ARCI)
CAMG 1,BRAD1↔GO L2
;TEST FOR "HIGHER" VERTEX - THE "LOWER" ONE IS BETWEEN ENDS.
CCW ARCO2,ARCO
ROW R,ARCI↔COL C,ARCI
ROW 0,ARCO↔ROW 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
CAMGE R,0↔GO L1↔CAMLE R,1↔GO L1
COL 0,ARCO↔COL 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
CAMGE C,0↔GO L1↔CAMLE C,1↔GO L1
;ARC OUTER IS "HIGHER".
L0: CCW ARCO,ARCO
CALL(DISTANCE,ARCO,ARCI)
CAMG 1,BRAD1↔GO L2↔CW ARCO,ARCO
SETQ(ARCO,{TRYHARD,ARCI,ARCO})
LAC ARCI,1(P)
JUMPE ARCO,POP2J.↔GO L2
;ARC INNER IS "HIGHER".
L1: CCW ARCI,ARCI
CALL(DISTANCE,ARCO,ARCI)
CAMG 1,BRAD1↔GO L2↔CW ARCI,ARCI
SETQ(ARCI,{TRYHARD,ARCO,ARCI})
LAC ARCO,1(P)
JUMPE ARCI,POP2J.↔GO L2
;MAKE ARC RADIAL LINKS BETWEEN INNER AND OUTER ARCS.
L2: TEST ARCO,ARCBIT↔GO[FATAL({ARCO ¬ARC})]
TEST ARCI,ARCBIT↔GO[FATAL({ARCI ¬ARC})]
EXO. ARCO,ARCI
ENDO. ARCI,ARCO
SKIPE FLAG↔POP2J ;EXIT SECOND TIME AROUND.
;TEST EASY ON THE LOWER VERTICES OF THE PARALLELS.
SETOM FLAG
CCW ARCO2,ARCO
CCW ARCI2,ARCI
CALL(DISTANCE,ARCO2,ARCI2)
CAMLE 1,BRAD1↔GO L3
LAC ARCO,ARCO2↔LAC ARCI,ARCI2↔GO L2
;TEST FOR "HIGHER" VERTEX - THE "LOWER" ONE IS BETWEEN ENDS.
L3: ROW R,ARCI2↔COL C,ARCI2
ROW 0,ARCO↔ROW 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
CAMGE R,0↔GO L1↔CAMLE R,1↔GO[LAC ARCO,ARCO2↔GO L1]
COL 0,ARCO↔COL 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
CAMGE C,0↔GO L1↔CAMLE C,1↔GO[LAC ARCO,ARCO2↔GO L1]
LAC ARCI,ARCI2↔GO L0
LIT
BEND;1/5/73-------------------------------------------------------
SUBR(DISTANCE)V1,V2-----------------------------------------------
BEGIN DISTANCE
DAC 2,TMP2↔DAC 3,TMP3
LAC 3,ARG2↔ROW 0,3↔COL 1,3
LAC 3,ARG1
ROW 2,3↔SUB 0,2↔IMUL 0,0
COL 2,3↔SUB 1,2↔IMUL 1,1
ADD 0,1↔FSC 217↔CALL(SQRT,0)
LAC 2,TMP2↔LAC 3,TMP3↔POP2J
DECLARE{TMP2,TMP3}
BEND;12/30/72-----------------------------------------------------
SUBR(TRYHARD)V0,V1-------------------------------------------------
BEGIN TRYHARD; TRY TO TIE V0 TO V1 BY SPLITTING THE ARC OF V1.
;BGB - 28 DECEMBER 1972.
ACCUMULATORS{V0,V1,V2,V3,A,B,C,D,Q,X,Y}
;PICKUP VERTICES.
LAC V0,ARG2
LAC V1,ARG1
CCW V2,V1
;PICKUP AND FLOAT LOCUS OF V0.
COL X,V0↔FLO X,
ROW Y,V0↔FLO Y,
;COMPUTE NORMALIZED EDGE COEFFICIENTS OF EDGE V1-V2.
ROW A,V1↔FLO A, ; A ← Y1.
COL B,V2↔FLO B, ; B ← X2.
COL C,V1↔FLO C, ; C ← X1.
ROW D,V2↔FLO D, ; D ← Y2.
LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
LAC 0,A↔FMPR 0,0
LAC 1,B↔FMPR 1,1↔
FADR 1,0↔CALL SQRT,1 ; Q ← SQRT(A*A + B*B).
FDVR A,1 ;DIVIDE BY Q.
FDVR B,1
FDVR C,1
;COMPUTE DISTANCE FROM V0 TO THE EDGE.
; Q ← A*X0 + B*Y0 + C.
LAC Q,A↔FMP Q,X
LAC 1,B↔FMP 1,Y
FAD Q,1↔FAD Q,C
MOVMS Q
;IF DISTANCE GREATER THAN BUNDLE-RADIUS-2 THEN EXIT.
CAMLE Q,BRAD2↔GO LOSE
;COMPUTE LOCUS OF FOOT OF PERPENDICULAR DROPPED FROM V0.
;Q ← 1/(A*A + B*B).
;D ← (B*X0 - A*Y0).
;X ← (B*D - A*C)*Q.
;Y ←-(A*D + B*C)*Q.
LAC 0,A↔FMP 0,0↔LAC 1,B↔FMP 1,1↔FAD 1,0↔SLACI Q,(1.0)↔FDVR Q,1
FMP X,B↔FMP Y,A↔FSB X,Y↔LACN Y,X↔FMP X,B↔FMP Y,A
LAC A↔FMP C↔FSBR X,↔FMPR X,Q↔FIX X,225000
LAC B↔FMP C↔FSBR Y,↔FMPR Y,Q↔FIX Y,225000
;MAKE CERTAIN THAT LOCUS OF V3 IS BETWEEN V1 AND V2.
ROW 0,V1↔ROW 1,V2
CAMLE 0,1↔EXCH 0,1
CAMGE Y,0↔GO LOSE
CAMLE Y,1↔GO LOSE
COL 0,V1↔COL 1,V2
CAMLE 0,1↔EXCH 0,1
CAMGE X,0↔GO LOSE
CAMLE X,1↔GO[
LOSE: SETZ 1,↔POP2J]
;SPLIT V1 AND TIE V3 TO V0.
SETQ(V3,{MAKE,[VBIT+ARCBIT+VREL]})
PGON 0,V1↔PGON. 0,V3
CNTRST 0,V1↔CNTRS. 0,V3
CCW. V2,V3↔CW. V3,V2
CCW. V3,V1↔CW. V1,V3
ROW. Y,V3↔COL. X,V3
;TRY TO FIND AN ARCLESS VERTEX NEAR V3.
ARC 1,V1↔JUMPE 1,LEXIT
ARC 2,V2↔JUMPE 1,LEXIT
CCW 1,1↔CAME 1,2↔GO[
ROW 0,1↔SUB 0,Y↔MOVMS↔CAILE 200↔GO .-2
COL 0,1↔SUB 0,X↔MOVMS↔CAILE 200↔GO .-2
ARC. 1,V3↔ARC. V3,1↔GO .+1]
LEXIT: LAC 1,V3↔POP2J
LIT
BEND;12/30/72-----------------------------------------------------
SUBR(MKWED1)IMAGE-------------------------------------------------
BEGIN MKWED1;MAKE WINGED EDGES PHASE-1. ;HANG EDGE ON EVER VERTEX.
;BGB - 2 JANUARY 1973.
ACCUMULATORS{A,IM,LV,PG,F,E,V1,V2}
SKIPN FLGKRK↔POP1J
;GET ONE OF EVERYTHING.
LAC IM,ARG1 ;IMAGE.
SON LV,IM↔DAC LV,LV0# ;LEVEL.
L1: SON PG,LV↔DAC PG,PG0# ;POLYGON.
SKIPN PG↔POP1J
L2: ARC V1,PG↔DAC V1,V0# ;VERTEX.
JUMPE V1,L4
SETQ F,{MKF,IM} ;FACE.
L3: SETQ E,{MKE,IM} ;EDGE.
;PASTE IN ONE FACE AND TWO VERTICES.
PFACE. F,E
PED. E,V1
CCW V2,V1
PVT. V1,E
NVT. V2,E
;MAKE WINGS ON PVT.
CW V1,V1↔PED A,V1
JUMPE A,.+5
NCCW. A,E↔PCW. A,E
NCW. E,A↔PCCW. E,A
;CLOSE POLYGON LOOP.
LAC V1,V2
CAME V2,V0↔GO L3
CW V1,V2
PED A,V1↔PED E,V2↔PED. E,F
NCCW. A,E↔PCW. A,E
NCW. E,A↔PCCW. E,A
;NEXT POLYGON OF A LEVEL & NEXT LEVEL OF AN IMAGE.
L4: CCW PG,PG↔CAME PG,PG0↔GO L2
CCW LV,LV↔CAME LV,LV0↔GO L1
POP1J
BEND;1/4/73-------------------------------------------------------
SUBR(MKWED2)IMAGE-------------------------------------------------
BEGIN MKWED2;MAKE WINGED EDGES PHASE-2.
;PLACE A TEMPORARY EDGE ON EVER RADIAL, THEN KILL THEM.
;BGB - 4 JANUARY 1973.
ACCUMULATORS{F1,F2,E,V1,V2}
SKIPN FLGKRK↔POP1J
;LOOP THRU THE POLYGONS OF THE IMAGE FROM INNERMOST TO OUTER ONES.
LAC 1,ARG1↔SON 1,1 ;IMAGE.
DAC 1,LV0#↔CCW 1,1 ;LEVEL.
L1: DAC 1,LV#↔SON 1,1↔DAC 1,PG0# ;POLYGON.
SKIPN PG0↔GO L6-3
L2: DAC 1,PG#↔ARC 1,1↔DAC 1,V0# ;VERTEX.
L3: DAC 1,V#↔DAC 1,V1
EXO V2,1↔JUMPE V2,L5 ;CHECK FOR RADIALS.
ENDO 0,V2↔CAME 0,V1↔GO L5 ;RECIPROCITY REQUIRED.
PED E,V2↔PFACE F2,E ;EXO POLYGONS FACE.
PED E,V1↔NFACE F1,E ;ENDO POLYGONS FACE.
;CREATE WINGED EDGE AT RADIAL.
JUMPE F1,[
SETQ E,{GLUEVV,F2,V2,F1,V1}↔GO L4]
CAME F1,F2↔GO[FATAL({MKWED2, F1 ≠ F2.})]
SETQ E,{MKFE,V1,F1,V2}
L4: MARK E,TMPBIT
;NEXT POLYGON OF A LEVEL & NEXT LEVEL OF AN IMAGE.
L5: LAC 1,V ↔CCW 1,1↔CAME 1,V0↔GO L3
LAC 1,PG↔CCW 1,1↔CAME 1,PG0↔GO L2
LAC 1,LV↔CCW 1,1↔CAME 1,LV0↔GO L1
;KILL ALL THE EDGES THAT WERE JUST CREATED.
LAC 1,ARG1↔NED 1,1↔DAC 1,EDGE
L6: LAC 1,EDGE#
NED 2,1↔DAC 2,EDGE ;SAVE NEXT ONE.
TEST 1,TMPBIT↔GO L7
TEST 1,EBIT↔GO L7
CALL(KLVE,1) ;KILL THIS ONE.
GO L6
L7: GO KL2SID ;OLDE LISP LIKE EXIT.
BEND;1/4/73-------------------------------------------------------
SUBR(KL2SID)IMAGE-------------------------------------------------
BEGIN KL2SID; BGB - 5 JAN 1973.
;KILL ALL THE 2 SIDED FACES OF AN IMAGE.
ACCUMULATORS{E,F1,F2}
LAC 1,ARG1↔PFACE F1,1↔GO L2+1
L1: PFACE F2,F1
DAC F2,FACE#
;TEST PED FOR IDENTICAL WINGS IN THE GIVEN FACE.
PED E,F1
PFACE 0,E
CAME 0,F1↔GO[
NCW 0,E↔NCCW 1,E↔GO .+3]
PCW 0,E↔PCCW 1,E
CAME 0,1↔GO L2
CALL(KLFE,E)
;ADVANCE TO NEXT FACE - EXIT ON NON-FACE.
L2: LAC F1,FACE
TEST F1,FBIT
POP1J
GO L1
LIT↔VAR
BEND;1/5/73-------------------------------------------------------
;TITLE WINGS - THE WINGED EDGE SUBROUTINES - JULY 1972.
COMMENT/ --- MODIFIED FOR CART'S EYE ----- 1 JANUARY 1973.
B ← BODY(Q);
FNEW ← MKF(B); KLF(FNEW);
ENEW ← MKE(B); KLE(ENEW);
VNEW ← MKV(B); KLV(VNEW);
WING(E1,E2); LINKED(Q1,Q2);
E ← ELEFT(V,F); E ← ERIGHT(V,F);
E ← ECW(E,Q); E ← ECCW(E,Q);
Q ← OTHER(E,Q); OTHER.(A,E,Q);
F ← FCW(E,V); F ← FCCW(E,V);
V ← VCW(E,F); V ← VCCW(E,F);
-----------------------------------------------------------------/
EXTERN MAKE,KILL
SUBR(BODY)Q-------------------------------------------------------
BEGIN BODY; BODY ≡ IMAGE FETCH - BGB - 1 JAN 73.
Q←1
LAC Q,ARG1
TESTZ Q,VBIT↔PED Q,Q
TESTZ Q,EBIT↔PFACE Q,Q
TESTZ Q,FBIT↔DAD Q,Q
TEST Q,IBIT↔SETZ Q,
POP1J
BEND;1/1/73-------------------------------------------------------
;FACE, EDGE & VERTEX MAKE PRIMITIVES.
;ACCUMULATOR TRANSPARENT AC2-AC17.
;READ IMAGE NODE FOR BODY NODE.
SUBR(MKF)B--------------------------------------------------------
BEGIN MKF
Q←1 ↔ X←2 ↔ B←3
CALL(MAKE,[FBIT+FREL])
EXCH B,ARG1↔LAC X
DAD. B,Q
NFACE X,B
PFACE. Q,X↔NFACE. Q,B
PFACE. B,Q↔NFACE. X,Q
EXCH B,ARG1↔EXCH X↔POP1J
BEND;1/1/73-------------------------------------------------------
SUBR(MKE)B--------------------------------------------------------
BEGIN MKE
Q←1 ↔ X←2 ↔ B←3
CALL(MAKE,[EBIT+EREL])
EXCH B,ARG1↔LAC X
NED X,B
PED. Q,X↔NED. Q,B
PED. B,Q↔NED. X,Q
EXCH B,ARG1↔EXCH X↔POP1J
BEND;1/1/73-------------------------------------------------------
SUBR(MKV)B--------------------------------------------------------
BEGIN MKV
Q←1 ↔ X←2 ↔ B←3
CALL(MAKE,[VBIT+VREL])
EXCH B,ARG1↔LAC X
NVT X,B
PVT. Q,X↔NVT. Q,B
PVT. B,Q↔NVT. X,Q
EXCH B,ARG1↔EXCH X↔POP1J
BEND;1/1/73-------------------------------------------------------
SUBR(KLF)FNEW-----------------------------------------------------
BEGIN KLF;KILL FACE - BGB - 2 JAN 73.
SKIPN 1,ARG1↔POP1J↔DAC 2,TMP#
NFACE 2,1↔PFACE 1,1 ;DELETE FROM FACE RING.
NFACE. 2,1↔PFACE. 1,2
CALL KILL,ARG1
LAC 2,TMP↔POP1J
BEND;1/2/73-------------------------------------------------------
SUBR(KLE)ENEW-----------------------------------------------------
BEGIN KLE;KILL EDGE - BGB - 2 JAN 73.
SKIPN 1,ARG1↔POP1J↔DAC 2,TMP#
NED 2,1↔PED 1,1 ;DELETE FROM EDGE RING.
NED. 2,1↔PED. 1,2
CALL KILL,ARG1
LAC 2,TMP↔POP1J
BEND;1/2/73-------------------------------------------------------
SUBR(KLV)---------------------------------------------------------
BEGIN KLV;KILL VERTEX - BGB - 2 JAN 73.
SKIPN 1,ARG1↔POP1J
TESTZ 1,ARCBIT↔POP1J ;DON'T KILL ARC VERTICES.
EXCH 2
NVT 2,1↔PVT 1,1 ;DELETE FROM VERTEX RING.
NVT. 2,1↔PVT. 1,2
CALL KILL,ARG1
EXCH 2↔POP1J
BEND;1/2/73-------------------------------------------------------
SUBR(WING)E1,E2---------------------------------------------------
BEGIN WING; - BGB - 1 JAN 73.
;WING(E1,E2) place wing pointers between two edges.
;THE AC-0 CONTROL BITS:
;[0-NV2-NV1] [0-PV2-PV1] [0-NF2-NF1] [0-PF2-PF1]
E1←3 ↔ E2←4
SAVAC(4)↔SETZ↔CDR E1,ARG2↔CDR E2,ARG1
;FIND THE COMMON VERTEX.
; AC-1 ← (NV1,,PV1) ⊗ (NV2,,PV2) NN,,PP in common.
; AC-2 ← (PV1,,NV1) ⊗ (NV2,,PV2) PN,,NP in common.
LAC 1,5(E1)↔MOVS 2,1↔XOR 1,5(E2)↔XOR 2,5(E2)
TLNN 1,-1↔TRO 3000↔TRNN 1,-1↔TRO 0300
TLNN 2,-1↔TRO 2100↔TRNN 2,-1↔TRO 1200
;FIND THE COMMON FACE.
LAC 1,3(E1)↔MOVS 2,1↔XOR 1,3(E2)↔XOR 2,3(E2)
TLNN 1,-1↔TRO 0030↔TRNN 1,-1↔TRO 0003
TLNN 2,-1↔TRO 0021↔TRNN 2,-1↔TRO 0012
;STORE THE WINGS AS INDICATED.
SETCA
TRNN 2020↔NCW. E1,E2↔TRNN 1010↔NCW. E2,E1
TRNN 2002↔PCCW. E1,E2↔TRNN 1001↔PCCW. E2,E1
TRNN 0220↔NCCW. E1,E2↔TRNN 0110↔NCCW. E2,E1
TRNN 0202↔PCW. E1,E2↔TRNN 0101↔PCW. E2,E1
GETAC(4)↔POP2J
BEND;1/1/73-------------------------------------------------------
;LINKED(Q1,Q2) - DETERMINE WHETHER TWO FEV ENTITIES ARE LINKED.
SUBR(LINKED)------------------------------------------------------
BEGIN LINKED
ACCUMULATORS{Q1,Q2,E}
CDR Q1,ARG2↔CDR Q2,ARG1
;BRANCH ON THE COMBINATION OF ARGUMENT TYPES.
TESTZ Q2,FBIT↔EXCH Q1,Q2
TEST Q1,FBIT↔GO L1 ;POTENTIAL FACE NOW IN Q1.
TESTZ Q2,FBIT↔GO FF
TESTZ Q2,EBIT↔GO FE
TESTZ Q2,VBIT↔GO FV↔GO FALSE
L1: TESTZ Q2,EBIT↔EXCH Q1,Q2
TEST Q1,EBIT↔GO L2 ;POTENTIAL EDGE NOW IN Q1.
TESTZ Q2,EBIT↔GO EE
TESTZ Q2,VBIT↔GO EV↔GO FALSE
L2: TEST Q1,VBIT↔GO FALSE
TEST Q2,VBIT↔GO FALSE↔GO VV
;FACES WITH COMMON EDGE.
FF: PED E,Q1↔DAC E,E0#
CALL OTHER,E,Q1↔CAMN 1,Q2↔GO TRUE
SETQ(E,{ECCW,E,Q1})↔CAME E,E0↔GO FF+2↔GO FALSE
;EDGE IN FACE PERIMETER.
FE: PFACE 1,Q2↔CAMN 1,Q1↔GO TRUE
NFACE 1,Q2↔CAMN 1,Q1↔GO TRUE↔GO FALSE
;VERTEX IN FACE PERIMETER.
FV: PED E,Q2↔DAC E,E0
JUMPE E,[PFACE 1,Q1↔PVT 0,Q2↔CAME 0,1↔GO FALSE↔GO TRUE]
PFACE 1,E↔CAMN 1,Q1↔GO TRUE↔NFACE 1,E↔CAMN 1,Q1↔GO TRUE
SETQ(E,{ECCW,E,Q2})↔CAME E,E0↔GO FV+2↔GO FALSE
;EDGES WITH A COMMON VERTEX.
EE: PVT 0,Q1↔PVT 1,Q2↔CAMN 0,1↔GO TRUE
NVT 1,Q2↔CAMN 0,1↔GO TRUE
NVT 0,Q1↔PVT 1,Q2↔CAMN 0,1↔GO TRUE
NVT 1,Q2↔CAMN 0,1↔GO TRUE↔GO FALSE
;VERTEX IN EDGE.
EV: PVT 1,Q1↔CAMN 1,Q2↔GO TRUE
NVT 1,Q1↔CAMN 1,Q2↔GO TRUE↔GO FALSE
;VERTICES WITH A COMMON EDGE.
VV: PED E,Q1↔DAC E,E0
CALL OTHER,E,Q1↔CAMN 1,Q2↔GO TRUE
SETQ(E,{ECCW,E,Q1})↔CAME E,E0↔GO VV+2↔GO FALSE
FALSE: SETZ 1,↔POP2J
TRUE: SETO 1,↔POP2J
LIT↔VAR
BEND;1/1/73-------------------------------------------------------
SUBR(ERIGHT)------------------------------------------------------
TDCA 1,1 ;E ← ERIGHT(FROM-V,ABOUT-F).
SUBR(ELEFT)-------------------------------------------------------
SETZ 1, ;E ← ELEFT(FROM-V,ABOUT-F).
; ELEFT ←-------V-------→ ERIGHT
; | |
; | F |
; | |
BEGIN EFETCH
ACCUMULATORS{V,F,E1,E2}
Q←1
SAVAC(5)
DAC Q,QFLAG#↔LAC V,ARG2↔LAC F,ARG1
TEST V,VBIT↔GO[SETCMM QFLAG↔EXCH F,V↔GO .+1]
PED E2,V↔DAC E2,E0#
L1: LAC E1,E2
;E2←ECW(E1,V) AND Q←FCW(E1,V).
PVT Q,E1↔CAME Q,V↔GO .+4↔NCCW E2,E1↔NFACE Q,E1↔GO .+6
NVT Q,E1↔CAME Q,V↔GO DIE↔PCCW E2,E1↔PFACE Q,E1
CAMN Q,F↔GO L2↔CAME E2,E0↔GO L1
DIE: FATAL(EFETCH)
L2: LAC 1,E1↔SKIPE QFLAG↔LAC 1,E2
GETAC(5)↔POP2J
BEND;1/1/73-------------------------------------------------------
;E←ECW(FROM-X,ABOUT-Y) - EDGE CLOCKWISE FROM X ABOUT Y.
SUBR(ECW)---------------------------------------------------------
BEGIN ECW
Q←1 ↔ X←2 ↔ E←3
CDR 1,ARG2↔TEST 1,EBIT↔GO ERIGHT
DAC 2,AC2↔ DAC 3,AC3
CDR X,ARG1↔LAC E,1
TEST X,VBIT↔GO[
PFACE Q,E↔CAME Q,X↔GO L1↔ PCW Q,E↔GO L
L1: NFACE Q,E↔CAME Q,X↔GO DIE↔ NCW Q,E↔GO L]
PVT Q,E↔CAME Q,X↔GO L2↔ NCCW Q,E↔GO L
L2: NVT Q,E↔CAME Q,X↔GO DIE↔ PCCW Q,E↔GO L
DIE: FATAL(ECW)
L: LAC 2,AC2↔ LAC 3,AC3↔ POP2J
LIT
BEND;1/1/73-------------------------------------------------------
SUBR(ECCW)--------------------------------------------------------
BEGIN ECCW
Q←1 ↔ X←2 ↔ E←3
CDR 1,ARG2↔TEST 1,EBIT↔GO ELEFT
DAC 2,AC2↔ DAC 3,AC3
CDR X,ARG1↔LAC E,1
TEST X,VBIT↔GO[
PFACE Q,E↔CAME Q,X↔GO L1↔ PCCW Q,E↔GO L
L1: NFACE Q,E↔CAME Q,X↔GO DIE↔ NCCW Q,E↔GO L]
PVT Q,E↔CAME Q,X↔GO L2↔ PCW Q,E↔GO L
L2: NVT Q,E↔CAME Q,X↔GO DIE↔ NCW Q,E↔GO L
DIE: FATAL(ECCW)
L: LAC 2,AC2↔ LAC 3,AC3↔ POP2J
LIT
BEND;1/1/73-------------------------------------------------------
SUBR(OTHER)-------------------------------------------------------
BEGIN OTHER
Q←1 ↔ X←2 ↔ E←3
DAC 2,AC2↔ DAC 3,AC3
CDR X,ARG1↔CDR E,ARG2
TEST X,VBIT↔GO[
PFACE Q,E↔CAME Q,X↔GO L1↔ NFACE Q,E↔GO L
L1: NFACE Q,E↔CAME Q,X↔GO DIE↔ PFACE Q,E↔GO L]
PVT Q,E↔CAME Q,X↔GO L2↔ NVT Q,E↔GO L
L2: NVT Q,E↔CAME Q,X↔GO DIE↔ PVT Q,E↔GO L
DIE: FATAL(OTHER)
L: LAC 2,AC2↔ LAC 3,AC3↔ POP2J
LIT
BEND;1/1/73-------------------------------------------------------
; OTHER.(Q,E,X)
SUBR(OTHER.)------------------------------------------------------
BEGIN OTHER.
Q←1↔ X←2↔ E←3
DAC AC0↔DAC 1,AC1↔DAC 2,AC2↔DAC 3,AC3
CDR X,ARG1↔ CDR E,ARG2↔ CDR Q,ARG3
TEST X,VBIT↔GO[
PFACE 0,E↔ CAME X↔ GO L1↔ NFACE. Q,E↔GO L
L1: NFACE 0,E↔ CAME X↔ GO DIE↔PFACE. Q,E↔GO L]
NVT 0,E↔ CAME X↔ GO L2↔ PVT. Q,E↔GO L
L2: PVT 0,E↔ CAME X↔ GO DIE↔NVT. Q,E↔GO L
DIE: FATAL(OTHER.)
L: LAC AC0↔LAC 1,AC1↔LAC 2,AC2↔LAC 3,AC3
POP3J↔LIT
BEND;1/1/73-------------------------------------------------------
;V ← VCW(E,F).
SUBR(VCW)---------------------------------------------------------
BEGIN VCW
Q←1 ↔ E←2
DAC 2,AC2
CDR E,ARG2
PFACE Q,E↔CAME Q,ARG1↔GO L1 ↔PVT Q,E↔GO L
L1: NFACE Q,E↔CAME Q,ARG1↔GO DIE↔NVT Q,E↔GO L
DIE: FATAL(VCW)
L: LAC 2,AC2↔POP2J↔LIT
BEND;1/1/73-------------------------------------------------------
;V ← VCCW(E,F).
SUBR(VCCW)--------------------------------------------------------
BEGIN VCCW
Q←1 ↔ E←2
DAC 2,AC2
CDR E,ARG2
PFACE Q,E↔CAME Q,ARG1↔GO L1 ↔NVT Q,E↔GO L
L1: NFACE Q,E↔CAME Q,ARG1↔GO DIE↔PVT Q,E↔GO L
DIE: FATAL(VCCW)
L: LAC 2,AC2↔POP2J↔LIT
BEND;1/1/73-------------------------------------------------------
;F ← FCW(E,V).
SUBR(FCW)---------------------------------------------------------
BEGIN FCW
Q←1 ↔ E←2
DAC 2,AC2
CDR E,ARG2
PVT Q,E↔CAME Q,ARG1↔GO L1 ↔NFACE Q,E↔GO L
L1: NVT Q,E↔CAME Q,ARG1↔GO DIE↔PFACE Q,E↔GO L
DIE: FATAL(FCW)
L: LAC 2,AC2↔POP2J↔LIT
BEND;1/1/73-------------------------------------------------------
;F ← FCCW(E,V).
SUBR(FCCW)--------------------------------------------------------
BEGIN FCCW
Q←1 ↔ E←2
DAC 2,AC2
CDR E,ARG2
PVT Q,E↔CAME Q,ARG1↔GO L1 ↔PFACE Q,E↔GO L
L1: NVT Q,E↔CAME Q,ARG1↔GO DIE↔NFACE Q,E↔GO L
DIE: FATAL(FCCW)
L: LAC 2,AC2↔POP2J↔LIT
BEND;1/1/73-------------------------------------------------------
;TITLE EULER - EULER SURFACE PRIMITIVES - JULY 1972 - BGB.
COMMENT/ - MODIFIED FOR CART'S EYE - 1 JANUARY 1973 - BGB.
These primitives preserve the Euler Equation F-E+V = 2*B-2*H;
which was named after Leonhard Euler,1707-1783, Swiss mathematician.
1. INVERT(E); Invert Edge.
2. VNEW ← MKEV(F,V); Make Edge Vertex.
3. ENEW ← MKFE(V1,F,V2); Make Face Edge.
4. VNEW ← ESPLIT(E); Edge Split.
5. F ← KLFE(ENEW); Kill Face Edge.
6. E ← KLEV(VNEW); Kill Edge Vertex.
7. V ← KLVE(ENEW); Kill Vertex Edge.
8. ENEW ← GLUEVV(F1,V1,F2,V2); Glue Vertex Vertex.
-----------------------------------------------------------------/
SUBR(INVERT)E-----------------------------------------------------
BEGIN INVERT
LAC 1,ARG1
FOR I⊂(0,1,3,5) {MOVSS I(1)↔}
POP1J
BEND;1/1/73-------------------------------------------------------
SUBR(MKEV)F,V-----------------------------------------------------
BEGIN MKEV;MAKE EDGE VERTEX - BGB - 1 JAN 73.
ACCUMULATORS {VNEW,B,F,V,ENEW,E1,E2}
;CHECK FOR BAD ARGUMENTS.
CDR VNEW,ARG1;FOR BAD RETURNS.
LAC V,ARG1↔TEST(V,VBIT)↔POP2J
LAC F,ARG2↔TEST(F,FBIT)↔POP2J
;CREATE A NEW EDGE AND VERTEX.
SETQ(B,{BODY,V})
SETQ(VNEW,{MKV,B})
SETQ(ENEW,{MKE,B})
;MAKE FACE AND VERTEX LINKS.
PED. ENEW,VNEW
NFACE. F,ENEW
PFACE. F,ENEW
NVT. VNEW,ENEW
PVT. V,ENEW
;CHECK FOR VERTEX BODY CASE.
PED E1,F↔JUMPE E1,[
PED. ENEW,F↔PED. ENEW,V
PCW. ENEW,ENEW↔NCCW. ENEW,ENEW↔GO .+1]
;LOWER WINGS POINT AT SELF.
NCW. ENEW,ENEW
PCCW. ENEW,ENEW
;GET THE UPPER WINGS.
PED E1,V↔LAC E2,E1
NFACE 0,E1↔PFACE 1,E1
CAMN 0,1↔GO L2
L1: LAC E1,E2
SETQ(E2,{ECW,E1,V})
CALL FCW,E1,V
CAME 1,F↔GO L1
;TIE ENEW TO ITS UPPER WINGS.
L2: PCW. E1,ENEW
NCCW. E2,ENEW
PVT 0,E1↔CAME 0,V↔GO[PCCW. ENEW,E1↔GO .+2]↔NCCW. ENEW,E1
PVT 0,E2↔CAME 0,V↔GO[NCW. ENEW,E2↔GO .+2]↔PCW. ENEW,E2
LAC 1,VNEW
POP2J↔LIT
BEND;1/1/73-------------------------------------------------------
SUBR(MKFE)V1,F,V2-------------------------------------------------
BEGIN MKFE; MAKE FACE EDGE, RETURN NEW EDGE.
ACCUMULATORS{V1,F,V2,FNEW,ENEW,E,E0,B,S12,N}
;FETCH THE ARGUMENTS.
CDR V1,ARG3
CDR F,ARG2
CDR V2,ARG1
;DO THE CREATIONS.
DAD B,F
SETQ(FNEW,{MKF,B})
SETQ(ENEW,{MKE,B})
;LINK ENEW.
PED. ENEW,F↔ PED. ENEW,FNEW
PFACE. F,ENEW↔ NFACE. FNEW,ENEW
PVT. V1,ENEW↔ NVT. V2,ENEW
;GET THE UPPER WINGS.
PED E,V1↔LAC E0,E↔MOVS 3(E)↔CAME 3(E)
GO[L1: LAC E0,E↔ SETQ(E,{ECW,E0,V1})
CALL(FCW,E0,V1)↔CAME 1,F↔GO L1↔GO .+1]
DAC E0,E1#↔DAC E,E2#
;GET THE LOWER WINGS.
PED E,V2↔LAC E0,E↔MOVS 3(E)↔CAME 3(E)
GO[L2: LAC E0,E↔ SETQ(E,{ECW,E0,V2})
CALL(FCW,E0,V2)↔CAME 1,F↔GO L2↔GO .+1]
DAC E0,E3#↔DAC E,E4#
COMMENT . MKFE MANDALA
o--------o o--------o
| E2 \ / E1 |
| nccw \ / pcw |
| \ / |
| pvt ⊗ V1 |
| | |
| FNEW ENEW F |
| | |
| nvt ⊗ V2 |
| / \ |
| ncw / \ pccw |
| E3 / \ E4 |
o--------o o--------o
-----------------------------------------------------------------.
;CDR V2'S TAIL REPLACING +F'S WITH FNEW.
LAC E,E3
L3: MOVS 1,3(E)↔CAME 1,3(E)↔GO L4
PFACE. FNEW,E
PCW E,E↔GO L3
;CCW FROM V1 REPLACING F'S WITH FNEW.
L4: LAC E0,E↔LAC E,E2
SETZM A#↔CAMN E0,E2↔GO L6
L5: TESTZ E,WASP↔JSR WASPS
NFACE 0,E
CAME F,0
GO[PFACE. FNEW,E↔GO .+2]
NFACE. FNEW,E
CAME E,E0
GO[DAC E,A↔SETQ(E,{ECCW,E,FNEW})↔GO L5]
;LINK THE WINGS.
L6: CALL WING,E1,ENEW
CALL WING,E2,ENEW
CALL WING,E3,ENEW
CALL WING,E4,ENEW
L7: LAC 1,ENEW
POP3J
WASPS: 0
PCW 1,E↔CAMN 1,A↔GO W1
PCCW 1,E↔CAME 1,A↔GO W2
W1: SETZM A↔MARKZ E,WASP↔PFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
TESTZ E,WASP↔GO W1↔GO @WASPS
W2: SETZM A↔MARKZ E,WASP↔NFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
TESTZ E,WASP↔GO W2↔GO @WASPS
LIT
BEND;1/1/73-------------------------------------------------------
;VNEW ← ESPLIT(E); "M" COMMAND.
SUBR(ESPLIT)E-----------------------------------------------------
BEGIN ESPLIT
ACCUMULATORS{VNEW,ENEW,B,E,V}
;CHECK FOR BAD ARGUMENTS.
CDR VNEW,ARG1
LAC E,VNEW
TEST E,EBIT↔GO L
PVT V,E
;CREATE A NEW EDGE AND VERTEX.
SETQ B,{BODY,E}
SETQ(VNEW,{MKV,B})
SETQ(ENEW,{MKE,B})
;UPDATE V'S FIRST PTR WHEN NECESSARY.
PED 0,V
CAMN 0,E
PED. ENEW,V
;PLACE VNEW BETWEEN E AND ENEW.
PED. ENEW,VNEW
PVT 0,E↔PVT. 0,ENEW
PVT. VNEW,E
NVT. VNEW,ENEW
PFACE 0,E↔PFACE. 0,ENEW
NFACE 0,E↔NFACE. 0,ENEW
;NEW UPPER WINGS ARE LIKE THE OLDE;
PCW 0,E↔CALL WING,0,ENEW
NCCW 0,E↔CALL WING,0,ENEW
;EDGES POINT AT EACH OTHER ACROSS VNEW.
NCCW. ENEW,E↔PCW. ENEW,E
NCW. E,ENEW↔PCCW. E,ENEW
L: LAC 1,VNEW↔POP1J
BEND;1/1/73-------------------------------------------------------
SUBR(KLFE)ENEW----------------------------------------------------
BEGIN KLFE;KILL FACE EDGE - BGB - 1 JAN 73.
ACCUMULATORS{ENEW,FNEW,V1,V2,E1,E2,E3,E4,E,F}
;PICK THINGS UP.
CDR ENEW,ARG1
PFACE F,ENEW↔ NFACE FNEW,ENEW
PVT V1,ENEW↔ NVT V2,ENEW
;GET THE WINGS.
PCW E1,ENEW
NCCW E2,ENEW
NCW E3,ENEW
PCCW E4,ENEW
;GET RID OF ENEW APPEARANCES IN F & V.
PED 0,V1↔ CAMN 0,ENEW↔ PED. E1,V1
PED 0,V2↔ CAMN 0,ENEW↔ PED. E3,V2
PED 0,F ↔ CAMN 0,ENEW↔ PED. E3,F
;GET RID OF FNEW APPEARANCES
LAC E,E2
L1: PFACE 0,E↔CAMN 0,FNEW↔GO[PFACE. F,E↔GO L2]
NFACE 0,E↔CAMN 0,FNEW↔GO[NFACE. F,E↔GO L2]
FATAL(KLFE)
L2: CAME E,E3↔GO[SETQ(E,{ECCW,E,F})↔GO L1]
;LINK WINGS TOGETHER ABOUT F.
CALL WING,E2,E1
CALL WING,E4,E3
;GET RID OF FNEW AND ENEW.
CALL KLF,FNEW
CALL KLE,ENEW
LAC 1,F↔POP1J
BEND;1/1/73-------------------------------------------------------
SUBR(KLEV)VNEW----------------------------------------------------
BEGIN KLEV;KILL EDGE VERTEX - BGB - 1 JAN 1973.
ACCUMULATORS{E,ENEW,V,VNEW,F}
CDR VNEW,ARG1↔PED ENEW,VNEW
SETQ(E,{ECCW,ENEW,VNEW})
CALL ECCW,E,VNEW↔CAME 1,ENEW
GO[CALL KLFE,1↔GO KLEV]
;ORIENT EDGES AS IN MANDALA.
NVT 0,ENEW↔ CAMN 0,VNEW↔ GO .+3↔ CALL INVERT,ENEW
PVT 0,E↔ CAMN 0,VNEW↔ GO .+3↔ CALL INVERT,E
;TIE E TO ITS NEW VERTEX.
PVT V,ENEW↔ PVT. V,E
;MAKE E'S UPPER WINGS LIKE ENEW'S.
PCW 0,ENEW↔ CALL WING,0,E
NCCW 0,ENEW↔ CALL WING,0,E
;ELIMINATE OCCURENCES OF ENEW IN F & V.
PED 0,V↔ CAMN 0,ENEW↔ PED. E,V
PFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
NFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
;PURGE 'EM.
CALL KLV,VNEW
CALL KLE,ENEW
LAC 1,E↔POP1J
LIT
BEND;1/1/73-------------------------------------------------------
COMMENT . \ pvt / KLEV MANDALA
\ /
nccw \ / pcw
\ /
V ⊗
|
ENEW |
| nvt
VNEW ⊗
| pvt
E |
|
⊗
/ \
ncw / \ pccw
/ \
/ nvt \
-----------------------------------------------------------------.
SUBR(KLVE)ENEW----------------------------------------------------
BEGIN KLVE; V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E).
;BGB - 1 JANUARY 1973.
ACCUMULATORS{A,E,E1,E2,E3,E4,V1,V2,CNT}
;PICK THINGS UP.
CDR E,ARG1↔NVT V1,E↔PVT V2,E
PCW E1,E↔NCCW E2,E↔NCW E3,E↔PCCW E4,E
;REPLACE FACE-VERTEX PED'S THAT MIGHT CONTAIN E.
PFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E1,1
NFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E2,1
PED 0,V2↔CAMN 0,E↔PED. E2,V2
TESTZ E,WASP↔GO[CALL WING,E1,E2↔CALL WING,E3,E4↔GO L3]
;REPLACE V1 WITH V2.
LAC A,E3↔LACI CNT,100
L1: PVT 1,A↔CAME 1,V1↔GO[NVT. V2,A↔GO .+2]↔PVT. V2,A
SETQ(A,{ECCW,A,V2})
CAME A,E↔SOJGE CNT,L1↔JUMPL CNT,[FATAL(KLVE-LOOP)]
;SPLICE WINGS TOGETHER.
CALL WING,E1,E4
CALL WING,E2,E3
;BURN THE GARBAGE.
CALL KLV,V1
L3: CALL KLE,E
LAC 1,V2
POP1J↔LIT
BEND;1/1/73-------------------------------------------------------
COMMENT . KLVE MANDALA
E2 \ / E1
nccw \ / pcw
\ /
pvt ⊗ V2
|
| E
|
nvt ⊗ V1
/ \
ncw / \ pccw
E3 / \ E4
-----------------------------------------------------------------.
SUBR(GLUEVV)F1,V1,F2,V2--------------------------------------------
BEGIN GLUEVV; BGB - 1 JANUARY 1973.
;ENEW ← GLUEVV(F1,V1,F2,V2) - LIKE TWO MKEV(F,V)'S BACK TO BACK.
Q←←1 ↔ ACCUMULATORS{F1,V1,F2,V2,B,E,E1,E2,E3,E4}
CDR F1,ARG4↔CDR V1,ARG3
CDR F2,ARG2↔CDR V2,ARG1
;REPLACE F2 WITH F1.
JUMPE F2,[PED E,V2↔GO .+2]↔PED E,F2
DAC E,E0#↔SETQ B,{BODY,E}
L1: PFACE Q,E↔CAMN Q,F2↔PFACE. F1,E
NFACE Q,E↔CAMN Q,F2↔NFACE. F1,E
SETQ(E,{ECCW,E,F1})
CAME E,E0↔GO L1
CALL KLF,F2
;EDGE CREATION
SETQ(E,{MKE,B})
MARK E,WASP
NFACE. F1,E↔PFACE. F1,E
NVT. V1,E↔PVT. V2,E
;MAKE WINGS
SETQ(E1,{ECW,V2,F1})↔PCW. E1,E
SETQ(E2,{ECW,E1,V2})↔NCCW. E2,E
SETQ(E3,{ECW,V1,F1})↔NCW. E3,E
SETQ(E4,{ECW,E3,V1})↔PCCW. E4,E
PVT Q,E1↔CAME Q,V2↔GO[PCCW. E,E1↔GO .+2]↔NCCW. E,E1
PVT Q,E2↔CAME Q,V2↔GO[NCW. E,E2↔GO .+2]↔PCW. E,E2
PVT Q,E3↔CAME Q,V1↔GO[PCCW. E,E3↔GO .+2]↔NCCW. E,E3
PVT Q,E4↔CAME Q,V1↔GO[NCW. E,E4↔GO .+2]↔PCW. E,E4
;MARK WASP WAIST ON POTENTIAL SPUR STARTING AT V1.
CAME E1,E2↔GO L2
MARK E1,WASP↔PVT V1,E1↔PED E1,V1
MOVS Q,1(E1)↔CAMN Q,1(E1)↔GO .-5
L2: LAC Q,E↔CALL INVERT,Q
POP4J↔LIT
BEND;1/1/73-------------------------------------------------------
END
EULER.FAI - EOF.